home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue56 / Splat / metafile.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-02-25  |  5.9 KB  |  194 lines

  1. unit MetaFile;
  2.  
  3. interface
  4.  
  5. uses Windows, SysUtils, Classes, Graphics, Shapes;
  6.  
  7. type
  8.   // Metafile shape. The shape is stored as a metafile resource.
  9.   // The initial size is small and increases with each generation.
  10.   // When the metafile is played, the basic colors are changed
  11.   // the shape's main color.
  12.   //
  13.   // Derived classes must call LoadMetafileResource or otherwise
  14.   // create the resource in the Metafile property.
  15.   //
  16.   // TMetafileShape is an abstract class (although it lacks abstract methods).
  17.   // Concrete classes derive from TMetafileShape and provide an actual
  18.   // metafile resource. By default, the class name is the resource name
  19.   // (after removing the leading T).
  20.   TMetafileShape = class(TShape)
  21.   private
  22.     fMetafile: TMetafile;
  23.     fBounds: TRect;
  24.   protected
  25.     procedure LoadMetafileResource(const ResID, ResType: PChar);
  26.     function ResourceType: PChar; virtual;
  27.     function ResourceName: string; virtual;
  28.   public
  29.     constructor Create(Position: TPoint); override;
  30.     destructor Destroy; override;
  31.     procedure AfterConstruction; override;
  32.  
  33.     procedure Draw(Canvas: TCanvas); override;
  34.     procedure ChangeSize; override;
  35.     property Metafile: TMetafile read fMetafile;
  36.     property Bounds: TRect read fBounds;
  37.     property Left: Integer read fBounds.Left write fBounds.Left;
  38.     property Right: Integer read fBounds.Right write fBounds.Right;
  39.     property Top: Integer read fBounds.Top write fBounds.Top;
  40.     property Bottom: Integer read fBounds.Bottom write fBounds.Bottom;
  41.   end;
  42.  
  43.   // For example, TSplat is a metafile shape that uses the "Splat" resource.
  44.   // See the ShapeRes.rc file for the actual resource.
  45.   TSplat = class(TMetafileShape);
  46.  
  47. implementation
  48.  
  49. { TMetafileShape }
  50.  
  51. procedure TMetafileShape.AfterConstruction;
  52. begin
  53.   inherited;
  54.   LoadMetafileResource(PChar(ResourceName), ResourceType);
  55. end;
  56.  
  57. constructor TMetafileShape.Create(Position: TPoint);
  58. begin
  59.   inherited;
  60.   fMetafile := TMetafile.Create;
  61. end;
  62.  
  63. destructor TMetafileShape.Destroy;
  64. begin
  65.   FreeAndNil(fMetafile);
  66.   inherited;
  67. end;
  68.  
  69. // Playback a single metafile record, changing the background color to
  70. // the shape's own color. After playing the metafile record, restore
  71. // the original color, so the next time the metafile is played,
  72. // the same change can occur (but the shape's color will be different).
  73. function EnumFunc(DC: HDC; Table: PHandleTable; Emfr: PEnhMetaRecord;
  74.   NumObjects: DWord; Self: TMetafileShape): LongBool; stdcall;
  75. var
  76.   ColorPtr: ^COLORREF;
  77. begin
  78.   ColorPtr := nil;
  79.   case Emfr.iType of
  80.   Emr_SetTextColor:
  81.     with PEmrSetTextColor(Emfr)^ do
  82.       if crColor = BackgroundColor then
  83.         ColorPtr := @crColor;
  84.   Emr_SetBkColor:
  85.     with PEmrSetBkColor(Emfr)^ do
  86.       if crColor = BackgroundColor then
  87.         ColorPtr := @crColor;
  88.   Emr_CreateBrushIndirect:
  89.     with PEmrCreateBrushIndirect(Emfr)^ do
  90.       if lb.lbColor = BackgroundColor then
  91.         ColorPtr := @lb.lbColor;
  92.   Emr_CreatePen:
  93.     with PEmrCreatePen(Emfr)^ do
  94.       if lopn.lopnColor = BackgroundColor then
  95.         ColorPtr := @lopn.lopnColor;
  96.   else
  97.     ; // Otherwise, leave the record alone.
  98.   end;
  99.  
  100.   // Set the metafile color to the shape's color.
  101.   if ColorPtr <> nil then
  102.     ColorPtr^ := Self.Color;
  103.     
  104.   Win32Check(PlayEnhMetaFileRecord(DC, Table^, Emfr^, NumObjects));
  105.  
  106.   // Restore the record's original color.
  107.   if ColorPtr <> nil then
  108.     ColorPtr^ := BackgroundColor;
  109.   Result := True;
  110. end;
  111.  
  112. // Draw a metafile by enumerating the metafile records.
  113. procedure TMetafileShape.Draw(Canvas: TCanvas);
  114. var
  115.   OldPalette, NewPalette: HPalette;
  116.   Rect: TRect;
  117. begin
  118.   BoundingBox(Rect);
  119.   Dec(Rect.Right);  // Metafile bounds include right and bottom do decrement
  120.   Dec(Rect.Bottom); // the TRect bounds, which ordinarily do not include them.
  121.   OldPalette := 0;
  122.   NewPalette := Metafile.Palette;
  123.   if NewPalette <> 0 then
  124.   begin
  125.     OldPalette := SelectPalette(Canvas.Handle, NewPalette, True);
  126.     RealizePalette(Canvas.Handle);
  127.   end;
  128.   Win32Check(EnumEnhMetaFile(Canvas.Handle, Metafile.Handle, @EnumFunc, Self, Rect));
  129.   if NewPalette <> 0 then
  130.     SelectPalette(Canvas.Handle, OldPalette, True);
  131. end;
  132.  
  133. // Load a metafile resource. The resource might be in the resource DLL
  134. // or in the main application.
  135. procedure TMetafileShape.LoadMetafileResource(const ResID, ResType: PChar);
  136. var
  137.   ResInstance: THandle;
  138.   Stream: TResourceStream;
  139. begin
  140.   ResInstance := FindResourceHInstance(hInstance);
  141.   if FindResource(ResInstance, ResID, ResType) = 0 then
  142.     ResInstance := hInstance;
  143.  
  144.   Stream := TResourceStream.CreateFromID(ResInstance, Integer(ResID), ResType);
  145.   try
  146.     Metafile.LoadFromStream(Stream);
  147.   finally
  148.     Stream.Free;
  149.   end;
  150.  
  151.   // The initial size is square--keep the original aspect ratio by
  152.   // shrinking the smaller dimension to match the metafile.
  153.   if Metafile.Width > Metafile.Height then
  154.     YSize := MulDiv(XSize, Metafile.Height, Metafile.Width)
  155.   else
  156.     XSize := MulDiv(YSize, Metafile.Width, Metafile.Height);
  157. end;
  158.  
  159. // Compute the next size, trying to maintain the metafile's aspect ratio.
  160. procedure TMetafileShape.ChangeSize;
  161. var
  162.   Delta: Integer;
  163. begin
  164.   Delta := Random(DeltaDimension);
  165.   if Metafile.Width > Metafile.Height then
  166.   begin
  167.     XSize := XSize + Delta;
  168.     YSize := YSize + MulDiv(Delta, Metafile.Height, Metafile.Width);
  169.   end
  170.   else
  171.   begin
  172.     XSize := XSize + MulDiv(Delta, Metafile.Width, Metafile.Height);
  173.     YSize := YSize + Delta;
  174.   end;
  175. end;
  176.  
  177. // Default resource name is the same as the class name, minus the leading 'T'.
  178. function TMetafileShape.ResourceName: string;
  179. begin
  180.   Result := Copy(ClassName, 2, MaxInt);
  181. end;
  182.  
  183. // Default resource type is 'Metafile'. The resource type
  184. // is not case sensitive.
  185. function TMetafileShape.ResourceType: PChar;
  186. begin
  187.   Result := 'Metafile';
  188. end;
  189.  
  190.  
  191. initialization
  192.   RegisterShapes([TSplat]);
  193. end.
  194.